{-
 -  Separ, Type/Main.hs
 -
 -  Copyright (c) 2010 Dariusz Leniowski. All Rights Reserved.
 -
 -  Redistribution and use in source and binary forms, with or without 
 -  modification, are permitted provided that the following conditions 
 -  are met:
 -
 -  1. Redistributions of source code must retain the above copyright 
 -     notice, this list of conditions and the following disclaimer.
 -
 -  2. Redistributions in binary form must reproduce the above copyright 
 -     notice, this list of conditions and the following disclaimer 
 -     in the documentation and/or other materials provided with 
 -     the distribution.
 -
 -  3. The name of the author may not be used to endorse or promote 
 -     products derived from this software without specific prior 
 -     written permission.
 -
 -  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 
 -  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 
 -  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
 -  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
 -  THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, 
 -  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 
 -  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 
 -  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 
 -  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 
 -  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING 
 -  IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 
 -  POSSIBILITY OF SUCH DAMAGE.
 -
 -}

-- Module Main where 
-- the entrypoint is
-- read the arguments/options (getArgs)
-- read the input (getContents), 
-- process each line (process) i.e.
--     tokenize (toWords and toTokens)
--     type it using dictionary (lookupDictionary)
--     parse sentence by combining (triangle and combine)
--     print (a list, a tree, a dot-syntax script)
-- quit on EOF or :q

module Type.Main where

import Control.Monad hiding (join)
import System
import           Data.Char
import           Data.List
import qualified Data.Map as Map
import           Data.Maybe

import qualified Type.Base
import           Type.Base hiding (eval)
-- just the (Evaluable Type) instance
import qualified Type.Eval()
import qualified Type.Satisfiability
import           Type.ClsType
import           Type.ClsData
import           Type.ClsDict

-- interface to normalize
normalize :: (Normalizable a,Show a) => a -> [a]
normalize ty = testMM $ Type.Satisfiability.normaloop ty (return ())

-- interface to eval
eval :: Type -> [Type]
eval ty = testMM $ Type.Base.eval ty

-- tree of parse
data ParseTree = Leaf Type String | Node Type ParseTree ParseTree deriving (Eq,Ord)
-- additional frame for special Eq and Ord instances
data PParseTree = P ParseTree
-- type for printing options
data PrintOption = OptList | OptTree | OptGraph | OptTex

-- getType from root
getType :: ParseTree -> Type
getType (Leaf t _) = t
getType (Node t _ _) = t

-- special instances for PParseTree
-- this way switch "-a" works (ugly hack)
-- unique deletes repeated instances with
-- respect to this classes, so redefining it
-- to do not care for tree would take care of
-- (NN NN) NN and NN (NN NN) repetitions
instance Eq PParseTree where
	(==) (P a) (P b) = (getType a == getType b)
instance Ord PParseTree where
	compare (P a) (P b) = compare (getType a) (getType b)

pparse :: ParseTree -> PParseTree
pparse t = P t
dparse :: PParseTree -> ParseTree
dparse (P t) = t

-- split delim list 
-- just a simple util O(kn)
-- there is no need for KMP or Boyer-Moore's algorithm
split :: Eq a => [a] -> [a] -> [[a]]
split delim ls = split' delim ls [] where
	split' _ [] acc = [reverse acc]
	split' delim ls@(hd:tl) acc = case stripPrefix delim ls of
		Nothing -> split' delim tl (hd : acc)
		Just t -> (reverse acc) : split' delim t []

-- join delim list_of_lists
join :: [a] -> [[a]] -> [a]
join delim l = concat (intersperse delim l)

-- relpace old new list
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace old new l = join new . split old $ l

-- basic show
instance Show ParseTree where
	show x = show' 0 x where
		show' n (Leaf t s) = (map (const ' ') [1..n]) ++ "<" ++ show t ++ "> \"" ++ s ++ "\"\n"
		show' n (Node t a b) = (map (const ' ') [1..n]) ++ "<" ++ show t ++ ">\n" ++ show' (n+4) a ++ show' (n+4) b

-- needed for showT, i.e. graphviz rendering
-- returns sequences of Ls and Rs of all leaves
-- so they can be aligned while drawing the graph
-- by the "rank = same" line
getLeafs :: String -> ParseTree -> [String]
getLeafs p t = getLeafs' [(p,t)] [] where
	getLeafs' [] acc = acc
	getLeafs' ((p,l@(Leaf _ _)):xs) acc = getLeafs' xs (p:acc)
	getLeafs' ((p,(Node _ a b)):xs) acc = getLeafs' (("L" ++ p,a):("R" ++ p,b):xs) acc

-- showT renders a ".dot" file for graphviz's dot tool
-- nothing happnes here
showT :: PrintOption -> [ParseTree] -> String
showT OptList ls = show $ unique $ map getType ls
showT OptTree ls = show ls
showT OptTex  ls = foldr1 (++) $ map showP' ls where
	showR t = 
		replace "." "\\ldot{}" $
		replace "-->" "\\mapsto" $
		replace "<--" "\\mapsfrom" $
		replace ">>>" "\\ggg" $
		replace "<<<" "\\lll" $
		replace "("   "\\naw{" $
		replace ")"        "}" $
		replace "{"   "\\{" $
		replace "}"   "\\}" $
		replace "`lca`" "\\vee" $
		replace "`gcd`" "\\wedge" $
		replace " " "\\ " $
			show t
	showP' t = "\\begin{parsetree}\n%\\newcommand{\\naw}[1]{(#1)}\n%\\newcommand{\\ldot}{.}\n" ++ showP "" t ++ "\\end{parsetree}\n"
	showP ident (Leaf t s) = ident ++ "(.$" ++ showR t ++ "$. `"++s++"')\n"
	showP ident (Node t a b) = ident ++ "(.$" ++ showR t ++ "$.\n" ++ 
		showP (ident ++ "\t") a ++ showP (ident ++ "\t") b ++ ident ++ ")\n"
showT OptGraph ls = 
	let n = length ls in let ls' = zip ls [1..n] in
	"digraph G {\n\tnode [style=\"filled,rounded\", color=\"gray\", shape=\"box\"];\n" ++ foldr showG "}\n" ls'
	where
		-- some showT auxiliary function
		-- in fact it could be local...
		showG :: (ParseTree,Int) -> String -> String
		showG (t,i) s = "\tsubgraph {\n" ++ (rank $ getLeafs p t) ++ showG' p t ("\t}\n\t" ++ (intercalate " -> " $ reverse $ getLeafs p t) ++ " [ color = none ];\n" ++ s) where
			-- starting path
			p = "N" ++ show i
			-- node to string
			ntos (Leaf t s) = "\"" ++ s ++ "\\n" ++ show t ++ "\""
			ntos (Node t _ _) = "\"" ++ show t ++ "\""
			-- "rank = same" line
			rank ls = "\t\t{ rank = same; " ++ (intercalate "; " ls) ++ "; }\n"
			-- "node [label = ...]" line
			label p n s = "\t\t" ++ p ++ " [ label=" ++ ntos n ++ " ];\n" ++ s
			-- another auxiliary
			showG' p l@(Leaf _ _) s = label p l s
			showG' p n@(Node t a b) s = label p n $           -- label
				"\t\t" ++ (p) ++ " -> L" ++ (p) ++ ";\n" ++   -- left edge
				"\t\t" ++ (p) ++ " -> R" ++ (p) ++ ";\n" ++   -- right edge
				showG' ("L" ++ p) a (showG' ("R" ++ p) b s)   -- show rest

-- parse sentence O(n^3)
-- combineTypes all terms in pairs, triples, quadruples, etc. 
-- until just a single tuple will cover the whole sentence
-- triples = [pair + elem, elem + pair]
-- quadruples = [elem + triple, pair + pair, triple + elem]
-- and so on... (it looks like a triangle)
triangle :: Ord a => ([a] -> [a] -> [a]) -> [[a]] -> [a]
triangle combin list = 
	let n = length list in
	-- it could be an array, but maps are just nicer, aren't they?
	let a0 = Map.fromList (zip [0..n-1] list) in
	let body len from split ax = 
		let a = ax Map.! (n * (split - 1) + from) in
		let b = ax Map.! (n * (len - 1 - split) + from + split) in
		Map.map unique $ 
			Map.insertWith (++) (n * (len - 1) + from) (combin a b) ax
	in let az = 
	-- and here are three for loops ;-)
		foldl (\a1 len -> 
			foldl (\a2 from ->
				foldl (\a3 split -> 
						body len from split a3
					) a2 [1..len-1]
				) a1 [0..n-len]
			) a0 [2..n]
	in 
	az Map.! (n * (n - 1))

-- combineTypes two list of types
combineTypes :: [ParseTree] -> [ParseTree] -> [ParseTree]
combineTypes as bs = unique $ do
	a <- as
	let ta = getType a
	b <- bs
	let tb = getType b
	map (\t -> Node t a b) $ mplus (eval $ ta >>> tb) (eval $ ta <<< tb)

-- same as before, but different types
combinePTypes :: [PParseTree] -> [PParseTree] -> [PParseTree]
combinePTypes as bs = 
	map pparse $ combineTypes (map dparse as) (map dparse bs)

-- take care of a single line
doLine :: String -> Maybe [[ParseTree]]
doLine ":quit" = Nothing
doLine ":q"    = Nothing
doLine (':':'e':'v':'a':'l':' ':rest) = 
	Just [map (\x -> Leaf x $ show t) $ eval t] where
		t = read rest :: Type
doLine (':':'e':' ':rest) = 
	Just [map (\x -> Leaf x $ show t) $ eval t] where
		t = read rest :: Type
doLine string = Just $ toWords string

-- break string into list of [ParseTree], but technicaly 
-- (Type,String) pairs (the leaves of ParseTree type)
-- first bool denotes special treatment for ":q" and ":quit"
-- so they will work only when being a whole line
toWords :: String -> [[ParseTree]]
toWords s = case dropWhile isSpace s of
	"" -> []
	s' -> (lookupDictionary w) : (toWords s'')
		where (w, s'') = toTokens s'

-- get classes from dictionary with regard to Title case
-- this Title case does not works properly :-|
-- TODO think of better way (this is not a problem 
-- for a moment since almost whole input is lowercase)
lookupDictionary :: String -> [ParseTree]
lookupDictionary s@(x:xs) | isUpper x && all isLower xs = 
	 map (flip Leaf s) $ let ds = dictionary s in
	if ds == [read "Unknown"] then dictionary (toLower x : xs) else ds
lookupDictionary s =  map (flip Leaf s) $ dictionary s

-- breaks String into (Token,String)
toTokens :: String -> (String,String)
-- empty string -> empty token
toTokens [] = ("","")
-- some abbreviations first, because of '.' character
toTokens     ('c':'f':'.':xs) = ( "cf.",xs)
toTokens ('e':'.':'g':'.':xs) = ("e.g.",xs)
toTokens ('e':'t':' ':'a':'l':'.':xs) = ("et al.",xs)
toTokens ('e':'t':'c':'.':xs) = ("etc.",xs)
toTokens ('i':'.':'a':'.':xs) = ("i.a.",xs)
toTokens ('i':'.':'e':'.':xs) = ("i.e.",xs)
toTokens ('p':'.':'a':'.':xs) = ("p.a.",xs)
toTokens ('q':'.':'v':'.':xs) = ("q.v.",xs)
toTokens     ('M':'r':'.':xs) = ( "Mr.",xs)
toTokens ('M':'r':'s':'.':xs) = ("Mrs.",xs)
toTokens     ('M':'s':'.':xs) = ( "Ms.",xs)
toTokens     ('C':'o':'.':xs) = ( "Co.",xs)
toTokens ('I':'n':'c':'.':xs) = ("Inc.",xs)
toTokens ('L':'t':'d':'.':xs) = ("Ltd.",xs)
toTokens ('A':'.':'D':'.':xs) = ("A.D.",xs)
toTokens ('B':'.':'C':'.':xs) = ("B.C.",xs)
toTokens ('N':'.':'B':'.':xs) = ("N.B.",xs)
toTokens ('U':'.':'S':'.':xs) = ("U.S.",xs)
-- eat up leading spaces
toTokens (x:xs)   | isSpace x = toTokens xs
-- try negative number
toTokens ('-':x:xs) | isNumber x = 
	let (a,as) = toTokens (x:xs) in 
	('-':a,as)
-- try positive number
toTokens (x:xs)   | isNumber x = 
	let (a,as) = span isNumber (x:xs) in
	let (b,bs) = tryParseNumber as in
	if null b then let (c,cs) = tryParseFraction as in (a ++ c, cs)
	else (a ++ b, bs)
	where
		-- numbers separated by comma like 19,000,000
		tryParseNumber ys@(',':_) = tryParseNumber' ',' ys
		-- numbers separated by space like 19 000 000
		tryParseNumber ys@(' ':_) = tryParseNumber' ' ' ys
		-- parse failed?
		tryParseNumber ys = ([],ys)
		-- when we know separator (sep) and it is correct (sep == z)
		tryParseNumber' sep (z:y:ys) | sep == z && isNumber y = 
			-- eat up numbers
			let (d,ds) = span isNumber (y:ys) in
			-- and continue
			let (e,es) = tryParseNumber' sep ds in
			(d ++ e, es)
			-- if not, finish
		tryParseNumber' _ ys = ([],ys)
		-- try parse fraction like [123].456 
		-- where [123] was already parsed by (span isNumber)
		tryParseFraction ('.':y:ys) | isNumber y = 
			let (f,fs) = span isNumber (y:ys) in ('.':f,fs)
		tryParseFraction ys = ([],ys)
-- try anything delimited by space
toTokens (x:y:xs) | isSpace y = ([x],xs)
-- try single symbol
toTokens (x:xs) | not $ isLetter x = ([x],xs)
-- otherwise a letter
toTokens xs@(x:_) | isLetter x = span test xs where
	test '-' = True
	test y = isLetter y
-- this should not happen
toTokens s = error $ "unknown symbols: " ++ s

-- process list of types into result end print it
-- Nothing means ":quit" has been encountered
process :: (PrintOption,Bool,Bool) -> Maybe [[ParseTree]] -> IO ()
process _ Nothing = exitWith ExitSuccess
process (opt,pre,srt) (Just []) = do putStrLn ""
process (opt,pre,srt) (Just ls) = do
	when pre $ putStrLn ("> " ++ (show $ map (map getType) ls))
	if srt then putStrLn $ showT opt $ triangle combineTypes ls
		else putStrLn $ showT opt $ map dparse $ triangle combinePTypes $ map (map pparse) ls

-- print help and usage
printHelp :: Bool -> IO a
printHelp silent = if silent then exitWith ExitSuccess else do
	putStrLn "   :: Separ ::   "
	putStrLn ""
	putStrLn "command line options:"
	putStrLn " -h -- help,    print this message"
	putStrLn " -e -- eval,    treat the rest of command line as input"
	putStrLn " -s -- silent,  do not print the header"
	putStrLn " -a -- all,     print all derivations"
	putStrLn " -i -- input,   print input types (in a list form)"
	putStrLn " -t -- tree,    print output in a tree form (default)"
	putStrLn " -g -- graph,   print output in graphviz format"
	--putStrLn " -x -- tex,     print output in TeX parsetree format"
	putStrLn " -l -- list,    print output as a simple list"
	putStrLn ""
	putStrLn "type while in program:"
	putStrLn " :q -- quit,    exit"
	putStrLn " :e -- eval,    eval"
	putStrLn ""
	putStrLn "contact: Dariusz Leniowski <dtldarek@gmail.com>"
	putStrLn ""
	exitWith ExitSuccess

-- parse options type
data ParseOptions = PO {
	silent     :: Bool, 
	printInput :: Bool,
	printAll   :: Bool,
	outputType :: PrintOption,
	evalArgs   :: Maybe [String]}

defaultOptions :: ParseOptions
defaultOptions = PO {
	silent     = False,
	printInput = False,
	printAll   = False,
	outputType = OptTree,
	evalArgs   = Nothing}

parseOptions :: [String] -> IO ParseOptions
parseOptions = parseOptions' defaultOptions where -- defaults
	parseOptions' options ("-s"      :args) = parseOptions' options {silent = True} args
	parseOptions' options ("--silent":args) = parseOptions' options {silent = True} args
	parseOptions' options ("-h"      :args) = printHelp False
	parseOptions' options ("--help"  :args) = printHelp False
	parseOptions' options ("-i"      :args) = parseOptions' options {printInput = True} args
	parseOptions' options ("--input" :args) = parseOptions' options {printInput = True} args
	parseOptions' options ("-a"      :args) = parseOptions' options {printAll = True} args
	parseOptions' options ("--all"   :args) = parseOptions' options {printAll = True} args
	parseOptions' options ("-t"      :args) = parseOptions' options {outputType = OptTree} args
	parseOptions' options ("--tree"  :args) = parseOptions' options {outputType = OptTree} args
	parseOptions' options ("-g"      :args) = parseOptions' options {outputType = OptGraph} args
	parseOptions' options ("--graph" :args) = parseOptions' options {outputType = OptGraph} args
	parseOptions' options ("-x"      :args) = parseOptions' options {outputType = OptTex} args
	parseOptions' options ("--tex"   :args) = parseOptions' options {outputType = OptTex} args
	parseOptions' options ("-l"      :args) = parseOptions' options {outputType = OptList} args
	parseOptions' options ("--list"  :args) = parseOptions' options {outputType = OptList} args
	parseOptions' options ("-e"      :args) = parseOptions' options {evalArgs = Just args} []
	parseOptions' options ("-eval"   :args) = parseOptions' options {evalArgs = Just args} []
	parseOptions' options [] = return options
	parseOptions' options _ = printHelp (silent options)

-- executable entry procedure
main :: IO ()
main = do
	args <- getArgs
	options <- parseOptions args
	when (not $ silent options) $ putStrLn "   :: Separ ::   "
	input <- case evalArgs options of
			-- getContents is lazy ^^ so only needed input is readed
			-- therefore I can use it like a list that ends at EOF
			-- even in interactive mode, Haskell rox
		Nothing -> getContents >>= return .lines
		Just arguments -> return [intercalate " " arguments]
	mapM_ (process (outputType options, printInput options, printAll options)) $ map doLine $ input
	exitWith ExitSuccess

